home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
cmpnew
/
cmpmulti.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
7KB
|
199 lines
;;; CMPMULT Multiple-value-call and Multiple-value-prog1.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(si:putprop 'multiple-value-call 'c1multiple-value-call 'c1special)
(si:putprop 'multiple-value-call 'c2multiple-value-call 'c2)
(si:putprop 'multiple-value-prog1 'c1multiple-value-prog1 'c1special)
(si:putprop 'multiple-value-prog1 'c2multiple-value-prog1 'c2)
(si:putprop 'values 'c1values 'c1)
(si:putprop 'values 'c2values 'c2)
(si:putprop 'multiple-value-setq 'c1multiple-value-setq 'c1)
(si:putprop 'multiple-value-setq 'c2multiple-value-setq 'c2)
(si:putprop 'multiple-value-bind 'c1multiple-value-bind 'c1)
(si:putprop 'multiple-value-bind 'c2multiple-value-bind 'c2)
(defun c1multiple-value-call (args &aux info funob)
(when (endp args) (too-few-args 'multiple-value-call 1 0))
(cond ((endp (cdr args)) (c1funcall args))
(t (setq funob (c1funob (car args)))
(setq info (copy-info (cadr funob)))
(setq args (c1args (cdr args) info))
(list 'multiple-value-call info funob args)))
)
(defun c2multiple-value-call (funob forms &aux (*vs* *vs*) loc top)
(cond ((endp (cdr forms))
(setq loc (save-funob funob))
(let ((*value-to-go* 'top)) (c2expr* (car forms)))
(c2funcall funob 'args-pushed loc))
(t
(setq top (next-cvar))
(setq loc (save-funob funob))
(wt-nl "{object *V" top "=base+" *vs* ";")
(base-used)
(dolist** (form forms)
(let ((*value-to-go* 'top)) (c2expr-top* form top))
(wt-nl "while(vs_base<vs_top)")
(wt-nl "{V" top "[0]=vs_base[0];V" top "++;vs_base++;}"))
(wt-nl "vs_base=base+" *vs* ";vs_top=V" top ";")
(base-used)
(c2funcall funob 'args-pushed loc)
(wt "}")))
)
(defun c1multiple-value-prog1 (args &aux (info (make-info)) form)
(when (endp args) (too-few-args 'multiple-value-prog1 1 0))
(setq form (c1expr* (car args) info))
(setq args (c1args (cdr args) info))
(list 'multiple-value-prog1 info form args)
)
(defun c2multiple-value-prog1 (form forms &aux (base (next-cvar))
(top (next-cvar)))
(let ((*value-to-go* 'top)) (c2expr* form))
(wt-nl "{object *V" top "=vs_top;object *V" base "=vs_base;")
(dolist** (form forms)
(let ((*value-to-go* 'trash)) (c2expr-top* form top)))
(wt-nl "vs_base=V" base ";vs_top=V" top ";}")
(unwind-exit 'fun-val)
)
(defun c1values (args &aux (info (make-info)))
(setq args (c1args args info))
(list 'values info args))
(defun c2values (forms &aux (base *vs*) (*vs* *vs*))
(cond ((null forms)
(wt-nl "vs_base=vs_top=base+" base ";")
(base-used)
(wt-nl "vs_base[0]=Cnil;"))
(t
(dolist** (form forms)
(let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* form)))
(wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
(base-used)))
(unwind-exit 'fun-val))
(defun c1multiple-value-setq (args &aux (info (make-info)) (vrefs nil))
(when (or (endp args) (endp (cdr args)))
(too-few-args 'multiple-value-setq 2 0))
(unless (endp (cddr args))
(too-many-args 'multiple-value-setq 2 (length args)))
(dolist (var (car args))
(cmpck (not (symbolp var)) "The variable ~s is not a symbol." var)
(cmpck (constantp var)
"The constant ~s is being assigned a value." var)
(setq var (c1vref var))
(push var vrefs)
(push (car var) (info-changed-vars info))
)
(list 'multiple-value-setq info (reverse vrefs) (c1expr* (cadr args) info))
)
(defun c2multiple-value-setq (vrefs form)
(let ((*value-to-go* 'top)) (c2expr* form))
(do ((vs vrefs (cdr vs)))
((endp vs))
(declare (object vs))
(let ((vref (car vs)))
(declare (object vref))
(wt-nl "if(vs_base<vs_top){")
(set-var 'fun-val (car vref) (cadr vref))
(unless (endp (cdr vs)) (wt-nl "vs_base++;"))
(wt-nl "}else{") (set-var nil (car vref) (cadr vref))
(wt "}"))
)
(cond ((null vrefs)
(wt-nl "if(vs_base=vs_top){vs_base[0]=Cnil;vs_top=vs_base+1;}")
(unwind-exit 'fun-val))
(t (unless (eq *exit* 'return) (wt-nl) (reset-top))
(unwind-exit (cons 'var (car vrefs)))))
)
(defun c1multiple-value-bind (args &aux (info (make-info))
(vars nil) (vnames nil) init-form
ss is ts body other-decls
(*vars* *vars*))
(when (or (endp args) (endp (cdr args)))
(too-few-args 'multiple-value-bind 2 (length args)))
(multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil))
(c1add-globals ss)
(dolist** (s (car args))
(let ((v (c1make-var s ss is ts)))
(push s vnames)
(push v vars)))
(setq init-form (c1expr* (cadr args) info))
(dolist* (v (reverse vars)) (push v *vars*))
(check-vdecl vnames ts is)
(setq body (c1decl-body other-decls body))
(add-info info (cadr body))
(setf (info-type info) (info-type (cadr body)))
(dolist** (var vars) (check-vref var))
(list 'multiple-value-bind info (reverse vars) init-form body)
)
(defun c2multiple-value-bind (vars init-form body
&aux (block-p nil) (labels nil)
(*unwind-exit* *unwind-exit*)
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
(declare (object block-p))
(dolist** (var vars)
(let ((kind (c2var-kind var)))
(declare (object kind))
(if kind
(let ((cvar (next-cvar)))
(setf (var-kind var) kind)
(setf (var-loc var) cvar)
(wt-nl)
(unless block-p (wt "{") (setq block-p t))
(wt (rep-type kind) "V" cvar ";"))
(setf (var-ref var) (vs-push)))))
(let ((*value-to-go* 'top)) (c2expr* init-form))
(let ((*clink* *clink*)
(*unwind-exit* *unwind-exit*)
(*ccb-vs* *ccb-vs*))
(do ((vs vars (cdr vs)))
((endp vs))
(declare (object vs))
(push (next-label) labels)
(wt-nl "if(vs_base>=vs_top){")
(reset-top)
(wt-go (car labels)) (wt "}")
(c2bind-loc (car vs) '(vs-base 0))
(unless (endp (cdr vs)) (wt-nl "vs_base++;"))))
(wt-nl) (reset-top)
(let ((label (next-label)))
(wt-nl) (wt-go label)
(setq labels (reverse labels))
(dolist** (v vars)
(wt-label (car labels))
(pop labels)
(c2bind-loc v nil))
(wt-label label))
(c2expr body)
(when block-p (wt "}"))
)